home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / CODEGEN.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  23.0 KB  |  796 lines
  1. ; CODEGEN.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*            Code Generation                    *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: Oct 1985            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. ;   Note:  The current implementation never changes REG-BASE, so the
  23. ;          registers may be sparsely used.  Consider using fewer registers
  24. ;          and implementing a wrap-around algorithm.
  25. ;
  26. ;   Note:  There is currently no check to ensure that DEST never exceeds
  27. ;          MAX-REGNUM.  Somebody ought to do something about that!
  28. ;       (Implementing wrap-around would fix this, too.)
  29.  
  30. (define pcs-gencode
  31.   (lambda (exp)
  32.     (letrec
  33. ;------!
  34.        ((debug-mode          pcs-debug-mode) 
  35.  
  36.     (max-regnum           62)    ; highest available register number
  37.                           ; r0 reserved for '()
  38.                           ; r63 used by ppeep
  39.     (compiled-lambda-list '())   ; code for previously compiled closures
  40.  
  41.     (gen-code
  42.         (lambda (entry-name ; label for the code block
  43.              body       ; expression to be compiled
  44.              bvl        ; bound variable list
  45.              lex-level  ; lambda nesting level
  46.              senv       ; stack component of the lexical environment
  47.              henv       ; heap component of the lexical environment
  48.              cenv)      ; compile-time component of the lex env
  49.           (letrec
  50. ;--------------!
  51.            (
  52.   (code       '())    ; list of generated instructions and labels
  53.   (tos         -1)    ; stack level (size of current frame)
  54.   (reg-base    -1)    ; stack offset equivalent to register 0
  55.   (last-label '())    ; last code entry label referenced
  56.  
  57.   (gen
  58.       (lambda (x dest tr?)
  59.     (cond ((atom? (car x))
  60.            (case (car x)
  61.          (quote        (gen-quote x dest tr?))
  62.          (#!TOKEN         (gen-id x dest tr?))
  63.          (lambda       (gen-closure x dest tr?))
  64.          (if           (gen-if x dest tr?))
  65.          (set!         (gen-set! x dest tr?))
  66.          (%call/cc     (gen-ccc x dest tr?))
  67.          (begin        (gen-begin (cdr x) dest tr?))
  68.          (%apply       (gen-apply x dest tr?))
  69.          (letrec       (gen-letrec x dest tr?))
  70.          (else         (gen-primitive x dest tr?))))
  71.           ((eq? (caar x) 'LAMBDA)
  72.            (gen-let x dest tr?))
  73.           (else
  74.            (gen-application x dest tr?)))))
  75.  
  76.   (gen-quote
  77.       (lambda (x dest tr?)
  78.     (emit-load dest
  79.            (if (null? (cadr x)) 0 x))        ; use R0 for '()
  80.     (continue dest tr?)))
  81.  
  82.   (gen-id
  83.       (lambda (id dest tr?)
  84.     (let ((name (id-name id))
  85.           (info (assq id senv)))
  86.       (if info
  87.           (let ((dlevel (- lex-level (cddr info)))
  88.             (offset (cadr info)))
  89.         (if (and (zero? dlevel) ( > offset tos))
  90.             (emit-load dest (- offset reg-base) name)
  91.             (emit-load dest `(STACK ,offset ,dlevel) name)))
  92.           (emit-load dest (list 'HEAP name)))
  93.       (continue dest tr?))))
  94.  
  95.   (gen-set!
  96.       (lambda (x dest tr?)
  97.     (let* ((id (cadr x))
  98.            (value (caddr x))
  99.            (name (id-name id))
  100.            (info (assq id senv)))
  101.       (gen value dest #F)
  102.       (if info
  103.           (let ((dlevel (- lex-level (cddr info)))
  104.             (offset (cadr info)))
  105.         (if (and (zero? dlevel) ( > offset tos))
  106.             (emit-load (- offset reg-base) dest (cons 'SET name))
  107.             (emit 'STORE `(STACK ,offset ,dlevel) dest name)))
  108.           (emit 'STORE (list 'HEAP name) dest))
  109.       (continue dest tr?))))
  110.  
  111.   (gen-closure
  112.       (lambda (x dest tr?)
  113.     (let ((label (lambda-label x))
  114.           (bvl   (lambda-bvl x)))
  115.       (gen-code label
  116.             (lambda-body x)
  117.             bvl
  118.             (add1 lex-level)
  119.             senv
  120.             henv
  121.             cenv)
  122.       (when (or debug-mode (lambda-closed? x))
  123.         (emit-load dest                ; set up closure name
  124.                (if (null? (lambda-debug x))
  125.                    0            ; use R0 for '()
  126.                    (list 'QUOTE (lambda-debug x))))
  127.         (emit 'CLOSE dest
  128.                      dest
  129.                  (list label (lambda-nargs x)))
  130.         (set! last-label label)
  131.         (continue dest tr?)))))
  132.  
  133.   (gen-if
  134.       (lambda (x dest tr?)
  135.     (let ((pred (if-pred x))
  136.           (then (if-then x))
  137.           (else (if-else x)))
  138.       (gen pred dest #F)
  139.       (restore-regs dest)
  140.       (let* ((tos0 tos)
  141.          (out  (gensym 'I)))
  142.         (cond                    ; (if a b '())
  143.             ((equal? else ''())
  144.          (emit-live dest)
  145.          (emit 'JUMP out 'NULL? dest)
  146.          (gen then dest tr?)
  147.          (restore-tos tos0 tr?)
  148.          (emit-label out)
  149.          (continue dest tr?)
  150.          )                    ; (if a '() c)
  151.         ((equal? then ''())
  152.          (emit 'NOT dest dest)
  153.          (emit-live dest)
  154.          (emit 'JUMP out 'NULL? dest)
  155.          (gen else dest tr?)
  156.          (restore-tos tos0 tr?)
  157.          (emit-label out)
  158.          (continue dest tr?)
  159.          )                   ; (if a a c)
  160.         ((or (eq? pred then)
  161.              (and (memq (car pred)    ; no side effects?
  162.                 '(%%get-global%%
  163.                   %%get-scoops%%
  164.                   %%get-fluid%%))
  165.               (equal? pred then)))
  166.          (emit-live dest)
  167.          (emit 'JUMP out 'T? dest)
  168.          (gen else dest tr?)
  169.          (restore-tos tos0 tr?)
  170.          (emit-label out)
  171.          (continue dest tr?)
  172.          )                   ; (if a b c)
  173.         (else
  174.          (let ((lelse (gensym 'L)))
  175.            (emit-live dest)
  176.            (emit 'JUMP lelse 'NULL? dest)
  177.            (gen then dest tr?)
  178.            (restore-tos tos0 tr?)
  179.            (when (not tr?)
  180.              (emit-live dest)
  181.              (emit-jump out))
  182.            (emit-label lelse)
  183.            (gen else dest tr?)
  184.            (restore-tos tos0 tr?)
  185.            (when (not tr?)
  186.              (emit-label out)))))
  187.         ))))
  188.  
  189.   (gen-ccc
  190.       (lambda (x dest tr?)
  191.     (let* ((fun (cadr x))
  192.            (info (assq fun cenv)))     ; CENV = () in debug mode
  193.       (if info
  194.           (let* ((label       (cadr info))        ; open call
  195.              (delta-level (- lex-level
  196.                      (caddr info)))
  197.              (delta-heap  (- (length henv)
  198.                      (length (cadddr info)))))
  199.         (set! last-label label)
  200.         (restore-regs dest)
  201.         (if (and tr? ( >= delta-level 0))
  202.             (emit 'CALL
  203.               `(OPEN-TR ,label ,delta-level ,delta-heap)
  204.               'CC)
  205.             (begin
  206.                (save-regs dest)
  207.                (emit 'CALL
  208.                  `(OPEN ,label ,delta-level ,delta-heap)
  209.                  'CC)
  210.                (emit-copy dest 1)
  211.                (continue dest tr?))))
  212.           (begin                    ; closed call
  213.          (gen fun dest #F)
  214.          (restore-regs dest)
  215.          (if tr?
  216.              (emit 'CALL 'CLOSED-TR 'CC dest)
  217.              (begin
  218.                 (save-regs dest)
  219.                 (emit 'CALL 'CLOSED 'CC dest)
  220.             (emit-copy dest 1))))))))
  221.  
  222.   (gen-begin
  223.       (lambda (x dest tr?)
  224.     (if (null? (cdr x))
  225.         (gen (car x) dest tr?)
  226.         (begin
  227.            (gen (car x) dest #F)
  228.            (gen-begin (cdr x) dest tr?)))))
  229.  
  230.   (gen-apply
  231.       (lambda (x dest tr?)
  232.     (let ((fun   (cadr x))
  233.           (arg   (caddr x))
  234.           (dest1 (add1 dest)))
  235.       (gen arg dest #F)
  236.       (gen fun dest1 #F)
  237.       (restore-regs dest)
  238.       (if tr?
  239.           (emit 'CALL 'CLOSED-APPLY-TR dest1 dest)
  240.           (begin
  241.              (save-regs dest)
  242.          (emit 'CALL 'CLOSED-APPLY dest1 dest)
  243.          (emit-copy dest 1))))))
  244.  
  245.   (gen-let
  246.       (lambda (x dest tr?)
  247.     (let ((fun  (car x))
  248.           (args (cdr x)))
  249.       (gen-args args dest)
  250.       (restore-regs dest)
  251.       (let ((save-henv henv)
  252.         (save-senv senv)
  253.         (save-cenv cenv))
  254.         (set! henv (cons '() henv))
  255.         (let ((newdest (extend-bvl (lambda-bvl fun) dest)))
  256.           (gen (lambda-body fun) newdest tr?)
  257.           (when (not tr?)
  258.             (restore-regs newdest)
  259.             (drop dest)
  260.             (drop-env (- (length henv)        ; normally 1 or 0
  261.                  (length save-henv)))
  262.             (emit-copy dest newdest))
  263.           (set! henv save-henv)
  264.           (set! senv save-senv)
  265.           (set! cenv save-cenv))))))
  266.  
  267.  
  268.   ;;
  269.   ;; LETREC pairs must be handled VERY carefully!  We pass over them three
  270.   ;; times in order to get CENV, SENV, and (especially) HENV correct when
  271.   ;; referenced from within the pair expressions.
  272.   ;;
  273.   ;; Pass 1 - Determine which runtime variables must be heap allocated
  274.   ;;          and reserve space for them on the heap-allocated stack.
  275.   ;;          When done, HENV and SENV reflect the proper lexical
  276.   ;;          environment for generating the code for the body AND the
  277.   ;;          pairs themselves.
  278.   ;;
  279.   ;; Pass 2 - Add all compile-time only variables and "well-behaved"
  280.   ;;          runtime variables to CENV.  Note that CENV entries include
  281.   ;;          the HENV in effect at the time of CLOSURE, which is AFTER all
  282.   ;;          pair IDs have been allocated homes (in the first pass).
  283.   ;;
  284.   ;; Pass 3 - Generate code to assign pair expression values to pair IDs.
  285.   ;;          Note that Passes 1 and 3 must have exactly the same behavior
  286.   ;;          with respect to maintaining DEST.  Thus, they have the same
  287.   ;;          general structure.
  288.  
  289.   (gen-letrec
  290.       (lambda (x dest tr?)
  291.     (let ((save-henv henv)
  292.           (save-senv senv)
  293.           (save-cenv cenv))
  294.       (set! henv (cons '() henv))            ; add a rib
  295.       (let ((newdest (gen-pairs (letrec-pairs x) dest))
  296.         (body    (letrec-body x)))
  297.         (gen body newdest tr?)
  298.         (when (not tr?)
  299.           (restore-regs newdest)
  300.           (drop dest)
  301.           (drop-env (- (length henv)        ; normally 1 or 0
  302.                    (length save-henv)))
  303.           (emit-copy dest newdest))
  304.         (set! henv save-henv)
  305.         (set! senv save-senv)
  306.         (set! cenv save-cenv)))))
  307.  
  308.   (gen-pairs
  309.       (lambda (pairs dest)
  310.     (gen-pairs-1 pairs dest)
  311.     (when (not debug-mode)
  312.           (gen-pairs-2 pairs))
  313.     (gen-pairs-3 pairs dest)))
  314.  
  315.   (gen-pairs-1
  316.       (lambda (pairs dest)
  317.     (if (null? pairs)
  318.         (if (null? (car henv))
  319.         (set! henv (cdr henv))
  320.         (begin
  321.           (set-car! henv (%reverse! (car henv)))
  322.           (emit 'PUSH-ENV (car henv))))
  323.         (let ((id  (caar pairs))
  324.           (exp (cadar pairs)))
  325.           (gen-pairs-1
  326.               (cdr pairs)
  327.           (if (or debug-mode (id-rtv? id))
  328.               (if (or debug-mode (id-heap? id))
  329.               (begin          ; heap-alloc lex var
  330.                  (set-car! henv
  331.                        (cons (id-name id) (car henv)))
  332.                  dest)
  333.               (begin          ; stack/reg-alloc lex var
  334.                  (set! senv
  335.                    (cons (cons id
  336.                            (cons (+ reg-base dest)
  337.                              lex-level))
  338.                      senv))
  339.                  (add1 dest)))  ; reserve a register
  340.               dest))))))
  341.  
  342.  
  343.   (gen-pairs-2
  344.       (lambda (pairs)
  345.     (when pairs                 ; not called in debug mode
  346.           (let ((id  (caar pairs))
  347.             (exp (cadar pairs)))
  348.         (when (or (not (id-rtv? id))
  349.               (and (not (id-set!? id))
  350.                    (eq? (car exp) 'lambda)
  351.                    (not (negative? (lambda-nargs exp)))))
  352.               (set! cenv
  353.                 (cons (list id (lambda-label exp)
  354.                     (add1 lex-level) henv)
  355.                   cenv))))
  356.           (gen-pairs-2 (cdr pairs)))))
  357.  
  358.   (gen-pairs-3
  359.       (lambda (pairs dest)
  360.     (if (null? pairs)
  361.         dest
  362.         (let ((id  (caar pairs))
  363.           (exp (cadar pairs)))
  364.           (gen exp dest #F)
  365.           (restore-regs dest)
  366.           (gen-pairs-3
  367.               (cdr pairs)
  368.           (if (or debug-mode (id-rtv? id))
  369.               (if (or debug-mode (id-heap? id))
  370.               (begin
  371.                 (when (not (equal? exp '(quote ())))
  372.                   (emit 'STORE (list 'HEAP (id-name id))
  373.                            dest))
  374.                 dest)
  375.               (add1 dest))
  376.               dest))))))
  377.  
  378.   ;; Bound variable lists are similar to LETREC pairs, but much easier to
  379.   ;; deal with, since they are always runtime variables.  Thus, EXTEND-BVL
  380.   ;; is a simplified combination of GEN-PAIRS-1 (setting up HENV and SENV)
  381.   ;; and GEN-PAIRS-3 (emitting PUSH-ENV instructions when needed).
  382.  
  383.   (extend-bvl
  384.       (lambda (bvl dest)
  385.     (extend-bvl-1 bvl dest)
  386.     (extend-bvl-2 bvl dest)))
  387.  
  388.   (extend-bvl-1
  389.       (lambda (bvl dest)
  390.     (if (null? bvl)
  391.         (if (and (not debug-mode)
  392.              (null? (car henv)))
  393.         (set! henv (cdr henv))        ; null env frame
  394.         (begin
  395.           (set-car! henv (%reverse! (car henv)))
  396.           (emit 'PUSH-ENV (car henv))))
  397.         (let ((id (car bvl)))
  398.           (if (or debug-mode (id-heap? id))
  399.           (set-car! henv (cons (id-name id) (car henv)))
  400.           (set! senv
  401.             (cons (cons id
  402.                     (cons (+ reg-base dest)
  403.                       lex-level))
  404.                   senv)))
  405.           (extend-bvl-1 (cdr bvl) (add1 dest))))))
  406.  
  407.   (extend-bvl-2
  408.       (lambda (bvl dest)
  409.     (if (null? bvl)
  410.         dest
  411.         (let ((id (car bvl)))
  412.           (when (or debug-mode (id-heap? id))
  413.             (emit 'STORE (list 'HEAP (id-name id)) dest))
  414.           (extend-bvl-2 (cdr bvl) (add1 dest))))))
  415.  
  416.   (gen-application
  417.       (lambda (x dest tr?)
  418.     (let ((fun (car x)))
  419.       (let ((nargs (length (cdr x))))
  420.         (when (not (zero? nargs))
  421.           (gen-args (cdr x) dest))
  422.         (let ((info (assq fun cenv)))    ; CENV = () in debug mode
  423.           (if info
  424.           ;; open call
  425.           (let* ((label       (cadr info))
  426.              (delta-level (- lex-level
  427.                      (caddr info)))
  428.              (delta-heap  (- (length henv)
  429.                      (length (cadddr info)))))
  430.             (when (not (= nargs (lambda-nargs (id-init fun))))
  431.               (syntax-error "Wrong number of arguments in call"
  432.                     (id-name fun)))
  433.             (set! last-label label)
  434.             (restore-regs dest)
  435.             (if (and tr?            ; tail recursive
  436.                  ( >= delta-level 0))    ; frame not needed
  437.             (begin
  438.                (move-regs dest 1 nargs)
  439.                (if (zero? delta-level)
  440.                    (begin
  441.                   (drop-all)
  442.                   (drop-env delta-heap)
  443.                   (emit-live nargs)
  444.                   (emit-jump label))
  445.                    (emit 'CALL
  446.                      `(OPEN-TR ,label ,delta-level
  447.                            ,delta-heap)
  448.                      (list nargs))))
  449.             (begin
  450.                (save-regs dest)
  451.                (move-regs dest 1 nargs)
  452.                (emit 'CALL
  453.                  `(OPEN ,label ,delta-level ,delta-heap)
  454.                  (list nargs))
  455.                (emit-copy dest 1)
  456.                (continue dest tr?))))
  457.           ;; closed call
  458.           (let ((funreg (+ dest nargs))    ; compute function here
  459.             (nargs1 (+ nargs 1)))    ; then move it here
  460.             ;; must compute function before moving regs down
  461.             (gen fun funreg #F)
  462.             (restore-regs dest)
  463.             (if tr?
  464.             (begin
  465.                (move-regs dest 1 nargs1)
  466.                (emit 'CALL
  467.                  'CLOSED-TR (list nargs) nargs1))
  468.             (begin
  469.                (save-regs dest)
  470.                (move-regs dest 1 nargs1)
  471.                (emit 'CALL
  472.                  `CLOSED (list nargs) nargs1)
  473.                (emit-copy dest 1))))))))))
  474.  
  475.   (out-of-registers!
  476.       (lambda ()
  477.     (error " *** Compiler ran out of registers ***")))
  478.  
  479.   (gen-args
  480.       (lambda (args dest)
  481.     (when args
  482.           (when (> dest max-regnum)
  483.             (out-of-registers!))
  484.           (gen (car args) dest #F)
  485.           (gen-args (cdr args)(add1 dest)))))
  486.  
  487.   (gen-primitive
  488.       (lambda (x dest tr?)
  489.     (let ((primop (car x)))
  490.     ;;      (when (null? primop)
  491.     ;;            (set! **null-primop** x)
  492.     ;;        (writeln "++ Null primop found, saved in **NULL-PRIMOP**"))
  493.       (cond (( >= (+ dest (length (cdr x))) max-regnum)
  494.          (out-of-registers!))
  495.         ((memq primop '(%%get-global%%  %%set-global%%
  496.                 %%get-scoops%%  %%set-scoops%%
  497.                 %%def-global%%  %%get-fluid%% 
  498.                 %%set-fluid%%   %%bind-fluid%%
  499.                 %%unbind-fluid%%))
  500.          (case primop
  501.            (%%get-global%%   (gen-global-ref x dest tr? 'HEAP))
  502.            (%%set-global%%   (gen-global-set x dest tr? 'HEAP))
  503.            (%%get-scoops%%   (gen-global-ref x dest tr? 'GLOBAL))
  504.            (%%set-scoops%%   (gen-global-set x dest tr? 'GLOBAL))
  505.            (%%def-global%%   (gen-global-def x dest tr?))
  506.            (%%get-fluid%%    (gen-fluid-ref x dest tr?))
  507.            (%%set-fluid%%    (gen-fluid-set x dest tr?))
  508.            (%%bind-fluid%%   (gen-fluid-bind x dest tr?))
  509.            (else             (gen-fluid-unbind x dest tr?))))
  510.                 ((memq primop '(%graphics %esc %mouse))    ;variable-length instructions
  511.                  (let* ((inst-length `(quote ,(length (cdr x))))
  512.                         (src-regs (gen-prim-args (cdr x) dest))
  513.                         (newdest (if (null? src-regs)
  514.                                      dest
  515.                                      (car src-regs)))
  516.                         (instr `(,primop ,newdest ,inst-length ,@src-regs)))
  517.                    (restore-regs dest)
  518.                    (emit* instr)
  519.                    (emit-copy dest newdest)
  520.                    (continue dest tr?)))
  521.         ((and (memq primop '(+ - * / ))
  522.               (eq? (car (caddr x)) 'quote)
  523.               (integer? (cadr (caddr x)))
  524.               (< (abs (cadr (caddr x))) 128))
  525.          (gen (cadr x) dest #F)
  526.          (restore-regs dest)
  527.          (emit (cdr (assq primop
  528.                   '((+ . %+imm)(- . %+imm)
  529.                     (* . %*imm)(/ . %/imm))))
  530.                dest
  531.                dest
  532.                (if (eq? primop '-)
  533.                `(quote ,(minus (cadr (caddr x))))
  534.                (caddr x)))
  535.          (continue dest tr?))
  536.         (else
  537.          (let* ((src-regs (gen-prim-args (cdr x) dest))
  538.             (newdest  (if (null? src-regs)
  539.                       dest
  540.                       (car src-regs)))
  541.             (instr    (cons primop (cons newdest src-regs))))
  542.            (restore-regs dest)
  543.            (emit* instr)
  544.            (emit-copy dest newdest)
  545.            (continue dest tr?)))))))
  546.  
  547.   (gen-prim-args
  548.       (lambda (args dest)
  549.     (cond ((null? args)                    ; 0 args
  550.            '())
  551.           ((null? (cdr args))              ; 1 arg
  552.            (gen (car args) dest #F)
  553.            (list dest))
  554.           (else
  555.            (let ((arg1 (car args))
  556.              (arg2 (cadr args))
  557.              (dest1 (+ dest 1)))
  558.          (if (and (memq (car arg1) '(quote #!TOKEN %%get-global%%))
  559.               (not (memq (car arg2) '(quote #!TOKEN %%get-global%%))))
  560.              (begin
  561.                (gen arg2 dest #F)
  562.                (gen arg1 dest1 #F)    ; lex var or constant
  563.                (cons dest1
  564.                  (cons dest
  565.                    (gen-prim-args (cddr args) (+ dest 2)))))
  566.              (begin
  567.                 (gen arg1 dest #F)
  568.             (cons dest (gen-prim-args (cdr args) dest1)))))))))
  569.  
  570.   (gen-global-ref
  571.       (lambda (x dest tr? kind)
  572.     (emit-load dest (list kind (cadr (cadr x))))
  573.     (continue dest tr?)))
  574.  
  575.   (gen-global-set
  576.       (lambda (x dest tr? kind)
  577.     (let ((symbol (cadr (cadr x)))
  578.           (value (caddr x)))
  579.       (gen value dest #F)
  580.       (restore-regs dest)
  581.       (emit 'STORE (list kind symbol) dest)
  582.       (continue dest tr?))))
  583.  
  584.   (gen-global-def
  585.       (lambda (x dest tr?)
  586.     (let ((symbol (cadr (cadr x)))
  587.           (value (caddr x)))
  588.       (gen value dest #F)
  589.       (restore-regs dest)
  590.       (emit 'STORE (list 'GLOBAL-DEF symbol) dest)
  591.       (emit-load dest (cadr x))
  592.       (continue dest tr?))))
  593.  
  594.   (gen-fluid-ref
  595.       (lambda (x dest tr?)
  596.     (emit-load dest (list 'FLUID (cadr (cadr x))))
  597.     (continue dest tr?)))
  598.  
  599.   (gen-fluid-set
  600.       (lambda (x dest tr?)
  601.     (let ((symbol (cadr (cadr x)))
  602.           (value (caddr x)))
  603.       (gen value dest #F)
  604.       (restore-regs dest)
  605.       (emit 'STORE (list 'FLUID symbol) dest)
  606.       (continue dest tr?))))
  607.  
  608.   (gen-fluid-bind
  609.       (lambda (x dest tr?)
  610.     (let ((symbol (cadr (cadr x)))
  611.           (value (caddr x)))
  612.       (gen value dest #F)
  613.       (restore-regs dest)
  614.       (emit 'BIND-FLUID symbol dest)
  615.       (continue dest tr?))))
  616.  
  617.   (gen-fluid-unbind
  618.       (lambda (x dest tr?)
  619.     (let ((symlist (cadr (cadr x))))
  620.       (emit 'UNBIND-FLUIDS symlist)
  621.       (continue dest tr?))))
  622.  
  623.   (continue
  624.       (lambda (dest tr?)
  625.     (when tr?                    ; tail recursive
  626.           (restore-regs dest)
  627.           (if (not (= dest 1))
  628.           (emit-copy 1 dest))
  629.           (emit 'CALL 'EXIT 1))))
  630.  
  631.   (emit
  632.       (lambda instr
  633.      (set! code (cons instr code))))
  634.  
  635.   (emit*
  636.       (lambda (instr)
  637.     (set! code (cons instr code))))
  638.  
  639.   (emit-label
  640.       (lambda (tag)
  641.     (set! code (cons tag code))))
  642.  
  643.   (emit-load
  644.       (lambda args
  645.      (set! code (cons (cons 'LOAD args) code))))
  646.  
  647.   (emit-copy
  648.       (lambda (dest src)
  649.     (if (not (= dest src))
  650.         (emit 'LOAD dest src))))
  651.   (emit-live
  652.       (lambda (reg)
  653.     (emit 'LIVE
  654.           (if (zero? reg)
  655.           '()
  656.           (cons 1 reg)))))
  657.  
  658.   (emit-jump
  659.       (lambda (label)
  660.     (set! code (cons (cons 'JUMP (cons label '(ALWAYS)))
  661.              code))))
  662.  
  663.   (emit-push
  664.       (lambda (reg)
  665.     (letrec
  666.       ((pushback
  667.          (lambda (reg prev curr)
  668.            (cond ((or (null? curr)        ; start
  669.               (atom? (car curr))  ; label
  670.               (memq (caar curr)
  671.                 '(POP PUSH DROP JUMP CALL))
  672.               (and (not (atom? (cdar curr)))
  673.                    (equal? reg (cadar curr))
  674.                    (or (not (eq? (caar curr) 'LOAD))
  675.                    (not (number? (caddr (car curr)))))))
  676.               (let ((tail (cons `(PUSH () ,reg) curr)))
  677.             (if (null? prev)
  678.                 (set! code tail)
  679.                 (set-cdr! prev tail))))
  680.              ((and (eq? (caar curr) 'LOAD)
  681.                (= reg (cadar curr))
  682.                (number? (caddr (car curr))))
  683.               (pushback (caddr (car curr)) curr (cdr curr)))
  684.              (else (pushback reg curr (cdr curr)))))))
  685.       (begin
  686.          (pushback reg '() code)
  687.          (set! tos (add1 tos))
  688.          (if (not (= tos (+ reg reg-base)))
  689.          (error " *** EMIT-PUSH error: " reg reg-base tos))))))
  690.  
  691.   (emit-pop
  692.       (lambda (reg)
  693.     (if (not (= tos (+ reg reg-base)))
  694.         (error " *** EMIT-POP error: " reg reg-base tos))
  695.     (emit 'POP reg)
  696.     (set! tos (sub1 tos))))
  697.  
  698.   (save-regs
  699.       (lambda (reg)
  700.     (let ((reg-to-push (add1 (- tos reg-base))))
  701.       (when ( < reg-to-push reg)
  702.         (emit-push reg-to-push)
  703.         (save-regs reg)))))
  704.  
  705.   (restore-regs
  706.       (lambda (reg)
  707.     (let ((reg-to-pop (- tos reg-base)))
  708.       (when ( >= reg-to-pop reg)
  709.         (emit-pop reg-to-pop)
  710.         (restore-regs reg)))))
  711.  
  712.   (restore-tos
  713.       (lambda (tos0 tr?)
  714.     (cond (tr?            (set! tos tos0))
  715.           (( > tos tos0)  (emit-pop (- tos reg-base))
  716.                   (restore-tos tos0 tr?))
  717.           (( < tos tos0)  (emit-push (add1 (- tos reg-base)))
  718.                   (restore-tos tos0 tr?)))))
  719.  
  720.   (drop-all
  721.       (lambda ()
  722.     (let ((count (add1 tos)))
  723.       (when ( > count 0)
  724.         (emit 'DROP (list count))
  725.         (set! tos -1)))))
  726.  
  727.   (drop              ; drop down to and including REG
  728.       (lambda (reg)
  729.     (let* ((newtos (sub1 (+ reg reg-base)))
  730.            (count  (- tos newtos)))
  731.       (when ( > count 0)
  732.         (emit 'DROP (list count))
  733.         (set! tos newtos)))))
  734.  
  735.   (drop-env
  736.       (lambda (count)
  737.     (when (> count 0)
  738.           (emit 'DROP-ENV (list count)))))
  739.  
  740.   (move-regs
  741.       (lambda (from to count)
  742.     (if ( > from to)
  743.         (when ( > count 0)
  744.           (emit-copy to from)
  745.           (move-regs (add1 from)(add1 to)(sub1 count))))))
  746.  
  747. ;--------------!
  748.                )                              ;; body of gen-code
  749.                (let ((save-henv henv)
  750.              (save-senv senv)
  751.              (save-cenv cenv))
  752.          (set! henv (cons '() henv))        ; add a rib
  753.          (let ((newdest (if (eq? entry-name '==main==)
  754.                     1
  755.                     (extend-bvl bvl 1))))
  756.            (gen body newdest #T)
  757.            (set! compiled-lambda-list
  758.              (cons (cons entry-name
  759.                      (cons last-label (%reverse! code)))
  760.                    compiled-lambda-list))
  761.            (set! henv save-henv)
  762.            (set! senv save-senv)
  763.            (set! cenv save-cenv)
  764.            )))))
  765.  
  766.   (flatten
  767.       (lambda (cl)
  768.     (if (null? cl)
  769.         cl
  770.         (let* ((first      (car cl))
  771.            (label      (car first))
  772.            (last-label (cadr first))
  773.            (oplist     (cddr first))
  774.            (rest       (flat** last-label (cdr cl) '())))
  775.           (cons label
  776.             (append! oplist
  777.                  (flatten rest)))))))
  778.                     
  779.  
  780.   (flat**
  781.       (lambda (label a b)
  782.     (cond ((null? label)         a)
  783.           ((null? a)             b)
  784.           ((eq? label (caar a))  (append! a b))
  785.           (else (flat** label (cdr a) (cons (car a) b))))))
  786.  
  787. ;------!
  788.         )
  789.        (begin                                 ;; body of pcs-gencode
  790.       (gen-code '==main== exp '() 1 '() '() '())
  791.       (let ((result (flatten compiled-lambda-list)))
  792.         (if (eq? pcs-debug-mode 'FULL)
  793.         (pp result))
  794.         result)
  795.       ))))
  796.